Nous avions des soucis avec la LDA la semaine dernière liés à la reproductibilité (seed non fixés) et liés aux métriques d’évaluation des topics. La fonction utilisée ne permettait pas de récupérer plus que les coefficients beta (et les mots ayant le coeff beta le plus élevé pour chaque topic).
La fonction stm permet de fixer une seed et de récupérer plus de métriques, comme nous allons le développer plus tard.
La préparation des données est légèrement différentes, il faut préparer le vocabulaire (ensemble de tous les mots) ainsi que les documents (noms des documents => n° des PAT).
# Préparation des documents
# Importation de res lemmat (voir Rapport du 04-12-25)
load(file = "res.lemmat.RData")
# step 1 : Create the Vocabulary
vocab <- unique(res.lemmat$lem.f) # => liste unique de mots
head(vocab)## [1] "portrait" "situer" "croiser" "région" "département"
## [6] "confluence"
# step 2 : Create a Word-to-Index Mapping
# on va associer les numéros des mots dans le vocabulaire (chaque mot prend un numero)
word_to_idx <- setNames(seq_along(vocab), vocab)
head(word_to_idx)## portrait situer croiser région département confluence
## 1 2 3 4 5 6
# Step 3: Count Word Occurrences per Document
# Group by document and count occurrences of each word
doc_word_counts <- res.lemmat %>%
group_by(doc, lem.f) %>%
summarise(count = n(), .groups = 'drop')
# we count the frequency of each word in each document
head(doc_word_counts)# step4 4 : create document list
# Get unique documents in order => liste des documents
unique_docs <- unique(res.lemmat$doc)
head(unique_docs) # correspondent aux lignes de la BDD qui ont une description (ex : la n°3 n'en a pas)## [1] "text1" "text2" "text4" "text5" "text6" "text8"
# Create the documents list
documents <- lapply(unique_docs, function(current_doc) {
# Filter words for this document
words_in_doc <- doc_word_counts %>%
filter(doc == current_doc)
# Convert words to indices
indices <- as.integer(word_to_idx[words_in_doc$lem.f])
counts <- as.integer(words_in_doc$count)
# Create 2-row matrix: row 1 = indices, row 2 = counts
matrix(c(indices, counts), nrow = 2, byrow = TRUE)
})
# on va créer une liste qui contient autant d'éléménts qu'il n'y a de textes, dans chaque élément, il y a les identifiants des mots qui sont cités dans le vocabulaire (le n° du mot ) et sa fréquence d'apparition dans ce texte
# Name the documents (optional but recommended)
names(documents) <- unique_docs
documents[[1]][1,1] # le premier mot du text 1 (par ordre alphabetique) est le numéro 135## [1] 135
## [1] "accessible"
## [1] 1
# Step 5 : prep with prep documents
out <- prepDocuments(documents, vocab,
lower.thresh = 1, # remove words appearing in only 1 doc
upper.thresh = Inf)## Removing 1628 of 4338 terms (1628 of 41418 tokens) due to frequency
## Your corpus now has 360 documents, 2710 terms and 39790 tokens.
On va ensuite créer une fonction qui créé le modèle de topic modelling avec la fonction stm.
lda.model <- function(k, seed) {
topic_model<-stm(documents,
vocab,
K=k, verbose=FALSE, init.type = "LDA",
seed = seed)
return(topic_model)
}Exemple de fonctionnement de la fonction et des sorties :
## A topic model with 9 topics, 360 documents and a 2710 word dictionary.
## Topic 1 Top Words:
## Highest Prob: agricole, agriculture, commun, population, métropole, culture, communauté
## FREX: métropole, démographique, urbain, pôle, caractériser, regrouper, près
## Lift: lin, contrairement, équin, théorique, mètre, trace, stimuler
## Score: démographique, suisse, normand, lin, plaine, regrouper, agglomération
## Topic 2 Top Words:
## Highest Prob: alimentaire, alimentation, pat, durable, action, local, territorial
## FREX: engager, action, contrat, éducation, élaboration, lutte, plan
## Lift: dénutrition, consulaire, pointe, recouper, restitution, pilote, assemblée
## Score: cirque, not, réunion, pad, bordelais, fédérer, pou
## Topic 3 Top Words:
## Highest Prob: alimentaire, local, commun, produit, population, également, production
## FREX: touristique, tourisme, petit, bénéficiaire, arboriculture, régional, aop
## Lift: châtaigne, fonds, internet, identitaire, organisationnel, calcaire, ski
## Score: estival, dénombrer, plastique, parisien, méridional, façade, boutique
## Topic 4 Top Words:
## Highest Prob: agricole, alimentaire, exploitation, an, important, faible, agriculture
## FREX: ménage, faible, taux, moyenne, inférieur, national, élevé
## Lift: contraignant, chaud, température, désert, distribuer, croître, espérance
## Score: médian, inférieur, moyenne, faiblesse, sau, faible, agglo
## Topic 5 Top Words:
## Highest Prob: agricole, alimentaire, enjeu, production, local, foncier, climatique
## FREX: changement, adaptation, climatique, valorisation, foncier, génération, renouvellement
## Lift: déterminer, certification, incitation, trait, emparer, fonctionnalité, généralisé
## Score: friche, accord, fonctionnalité, changement, certification, économe, rhd
## Topic 6 Top Words:
## Highest Prob: alimentaire, alimentation, enjeu, agricole, local, qualité, production
## FREX: défi, réduire, modèle, carbone, mode, maladie, atlantique
## Lift: triple, priorisation, biomasse, surmonter, exacerber, méthode, acheminement
## Score: atlantique, empreinte, protéine, maladie, géopolitique, modèle, durablement
## Topic 7 Top Words:
## Highest Prob: exploitation, production, agricole, élevage, local, produit, agriculture
## FREX: cheptel, lait, bovin, volaille, porcin, ovin, élevage
## Lift: porc, acceptation, horaire, fertilisant, estive, ugb, recevoir
## Score: provençal, volaille, cheptel, utiliser, perdre, sau, horaire
## Topic 8 Top Words:
## Highest Prob: local, collectif, produit, restauration, production, alimentaire, circuit
## FREX: collectif, restauration, demander, logistique, circuit, approvisionnement, consommateur
## Lift: boucherie, sourcing, gustatif, régularité, casier, coup, comparativement
## Score: logistique, restauration, plateforme, sourcing, produit, rapprocher, bouche
## Topic 9 Top Words:
## Highest Prob: enjeu, pat, local, action, alimentation, agricole, développement
## FREX: schéma, stratégique, soin, bocage, affirmer, ruralité, comité
## Lift: vivable, fourche, récemment, certifié, authentique, moderne, élaboré
## Score: schéma, comité, capable, pilotage, r, renouer, moderne
Une première méthode à laquelle nous avons pensé consistait à afficher un graphique à la manière des valeurs propres en ACP pour décider du nombre de topics que l’on choisit pour notre LDA. On a créé une fonction qui prend en compte 2 arguments (nstart et nend), qui correspondent aux valeurs minimum et maximum du nombre de topics qu’on fixe dans notre LDA, la fonction teste pour toutes les valeurs de k comprises dans cet intervalle.
#On charge le simple triplet matrix que nous avions fait dans le rapport du 04-12
stm <- load(file="stm.RData")# install.packages("topicdoc")
library(topicdoc)
library(tidyverse)
load(file = 'stm.RData')
#Fonction visant à produir un graph montrant la cohérence moyenne des topicss proposé à la sortie d'une LDA entre 2 valeurs du nombre de topics
# nstart : nombre de topics minimum
# nend : nombre de topics maximum
# La fonction a un pas de 1 pour les valeurs de k, il est donc recommandé de ne pas mettre des valeurs trop éloignées
coherence_graph <- function(nstart,nend){
L <- as.data.frame(matrix(nrow=nend-nstart+1,ncol=2))
colnames(L) <- c("k","min_coherence")
L$k <- nstart:nend
for (k_topic in nstart:nend){
lda_model <- LDA(stm, k = k_topic, method = "Gibbs",
control = list(seed = as.integer(800)))
L$min_coherence[k_topic-nstart+1] <- min(topic_coherence(lda_model,stm))
}
return(L)
}
coherence <- coherence_graph(2,5)
coherence %>% ggplot(aes(x=k,y=min_coherence)) +
geom_line() +
geom_point() +
ggtitle("Cohérence moyenne des topics en fonction du nombre de topics")On récupère les 7 mots qui ont les scores les plus élevés par TOPIC pour les métriques suivantes : - coefficients beta : rappel => probabilité d’appartenance d’un terme dans un topic
\[\text{FREX}_{f,k} = \left( \frac{w}{\text{ECDF}_{\varphi,k}(\varphi_{f,k})} + \frac{1-w}{\text{ECDF}_{\mu,k}(\mu_{f,k})} \right)^{-1}\]
avec :
terme 1 - ECDF = fonction de répartition empirique cumulative des fréquences des mots d’un thème - \(\varphi_{f,k}\) = fréquence du mot f dans le topic k
terme 2 : - \(\mu_{f,k}\) : exclusivité d’un mot f dans un topic k - fonction de répartition empirique cumulative des exclusivité dans le topic k
Cet indice met l’accent sur des mots typiques et plus exclusifs des thèmes. La fréquence de certains termes très génériques présents dans le corpus et qui se retrouvent dans de nombreux thèmes (alimentaire, alimentation, territoire). Les mots avec le score le plus élevé sont ceux qui sont à la fois assez fréquents et à la fois assez exclusifs à un thème Bischof et al, 2012
On va ensuite créer une fonction qui va récupérer les mots qui caractérisent le plus nos topics extraits.
=> il faut donc choisir les métriques qui nous intéressent :
topic.extraction <- function(topic_model) {
# récupérer les mots avec les indices FREX (Fréquence exclusivité) les plus forts
frex <- data.frame(t(summary(topic_model)$frex))
# beta <- data.frame(t(summary(topic_model)$prob)) # et les scores beta les plus élevés
# créer liste_mots
# liste_mots <- rbind(frex,beta)
colnames(frex) <- paste0("topic",seq(from=1,to=9))
list <- sapply(frex, paste, collapse = " ")
list <- str_split(list, pattern = " ")
return (list)
}Extraction des termes de chaque thème avec Beta et frex et montrer que frex est plus discriminant :
On va ensuite essayer de créer des “formes fortes” , en réalisant de nombreuses fois la LDA, puis en supprimant les mots les moins fréquents (n’apparaissant par exemple que dans un seul topic d’une seule LDA), et en regardant comment les mêmes mots s’associent de la même façon ensemble avec plusieurs itérations de l’algorithme. Les mots ne sont pas mis dans le même topic à chaque LDA, donc le ‘topic 1’ de la ‘lda1’ n’est pas le même que le ‘topic1’ de la ‘lda2’ mais s’il y a une stabilité dans les thèmes alors les mêmes mots se retrouveront dans les mêmes topics, et l’on s’intéresse justement aux termes qui composent ces topics (= la variable latente à nommer) plutôt qu’aux topics (1, 2, … etc) en eux-mêmes.
Nous avons testé plusieurs K, (9, 10, 15) et nous avons décidé de conserver k = 9 (augmenter le nombre de topics a eut pour effet que les mots associés dans les topics n’est pas forcément de sens ensemble donc la construction de l’espace latent des topics et la classification étaient peu satisfaisantes).
Nous avons essayé de réaliser la procédure en gardant les termes ayant les frex et les scores beta les plus élevés, et après avoir testé avec uniquement les scores frex, les groupes sont beaucoup plus discriminés donc nous avons décidé de ne conserver que cet indicateur permettant de construire des topics avec des termes suffisamment exclusifs de chaque topic.
Nous avons aussi essayé de conserver tous les mots dans l’espace latent final, cependant appliquer un filtre de fréquence (si un terme n’apparait qu’un nombre x minimal de fois dans l’ensemble des exécutions de l’algorithme) permet de réduire le nombre de points et de conserver des mots qui se retrouvent dans au moins plusieurs lda.
Nous réalisons n = 10 LDA que nous lançons à partir d’une seed aléatoire (que ici nous fixerons pour que les résultats soient exactement identiques).
# model1 <- lda.model(k = k, seed = seeds[1])
# model2 <- lda.model(k = k, seed = seeds[2])
# model3 <- lda.model(k = k, seed = seeds[3])
# model4 <- lda.model(k = k, seed = seeds[4])
# model5 <- lda.model(k = k, seed = seeds[5])
# model6 <- lda.model(k = k, seed = seeds[6])
# model7 <- lda.model(k = k, seed = seeds[7])
# model8 <- lda.model(k = k, seed = seeds[8])
# model9 <- lda.model(k = k, seed = seeds[9])
# model10 <- lda.model(k = k, seed = seeds[10])
# save(model1,model2,model3,model4,model5,model6,model7,model8,model9,model10, file = "modeles.RData")
load("modeles.RData")## A topic model with 9 topics, 360 documents and a 2708 word dictionary.
## A topic model with 9 topics, 360 documents and a 2708 word dictionary.
## A topic model with 9 topics, 360 documents and a 2708 word dictionary.
## A topic model with 9 topics, 360 documents and a 2708 word dictionary.
## A topic model with 9 topics, 360 documents and a 2708 word dictionary.
## A topic model with 9 topics, 360 documents and a 2708 word dictionary.
## A topic model with 9 topics, 360 documents and a 2708 word dictionary.
## A topic model with 9 topics, 360 documents and a 2708 word dictionary.
## A topic model with 9 topics, 360 documents and a 2708 word dictionary.
## A topic model with 9 topics, 360 documents and a 2708 word dictionary.
## [[1]]
## [1] "aop" "court" "circuit" "attente" "lait" "bovin" "domicile"
##
## [[2]]
## [1] "atlantique" "serrer" "carbone" "maladie" "mode"
## [6] "protéine" "gaz"
##
## [[3]]
## [1] "schéma" "action" "engager" "inscrire"
## [5] "communautaire" "partenaire" "opérationnel"
##
## [[4]]
## [1] "gaspillage" "egalim" "collectif" "restauration"
## [5] "sensibilisation" "loi" "précarité"
##
## [[5]]
## [1] "pression" "artificialisation" "soumettre"
## [4] "littoral" "attractivité" "climatique"
## [7] "risque"
##
## [[6]]
## [1] "vallée" "regrouper" "plaine" "urbain" "concentrer"
## [6] "montagne" "situer"
on va ensuite mettre tous les mots ensemble :
lda_list <- list(words1,words2,words3,words4,words5,words6,words7,words8,words9,words10)
# on créé la liste avec les mots de chaque lda : n objets, contenant chacun k éléments (9 ici)
words <- unique(unlist(lda_list))# récupére la liste unique des mots de toutes les lda
# ajouter toutes les listes de mots et on créé un tableau de données contenant en ligne les mots, en colonne chaque topic de chaque lda, et au croisement un “1” si le mot se retrouve dans les termes sélectionnés caractérisant ce topic, et sinon un “0”.
# Créer le data frame
col = paste0("lda", rep(1:nb_lda, each = k), "_topic", rep(1:k, times = nb_lda))
# on crée un vecteur avec les noms de colonnes avec x lda et n topics, et on le met dans l'ordre des lda
# c'est le vecteur des noms de colonnes de notre df
mfa.df = data.frame(matrix(ncol = k *nb_lda, nrow = length(words), NA))
# on créé le df => 1 + k * n colonnes , on le remplit de NA
colnames(mfa.df) <- col
# on met les noms de colonnes issus du vecteur col
rownames(mfa.df) <- words
# on ajoute les mots dans la colonne wordsOn va ensuite remplir le df :
# On va ensuite associer à chaque lda les mots des différents topics
for (i in 1:nb_lda) {
for (j in 1:k) {
col_name <- paste0("lda", i, "_topic", j)
# récupération des mots du topic j de la lda i
words_in_topic <- lda_list[[i]][[j]]
# lda_list[[i]][[j]] retourne les mots du topic j de la lda i
# pour chaque mot du dataframe
mfa.df[[col_name]] <- ifelse(
rownames(mfa.df) %in% words_in_topic,
1, # si le mot est dans ce topic
0
)
}
}
head(mfa.df[,1:10])Et on impose un filtre qui va d’abord calculer la somme de chaque ligne = le nombre de 1 = le nombre d’occurence de chaque mot sur l’ensemble des lda dans l’ensemble des topics Si cette fréquence est de 1, alors le mot (la ligne) est supprimée. On récupère ensuite le df final.
mfa.df.filtre <- mfa.df
mfa.df.filtre$freq <- apply(mfa.df, 1, sum)
# avec freq >= 2
mfa.df.filtre <- subset(mfa.df.filtre, freq>=2)
mfa.df.final <- mfa.df.filtre[,-ncol(mfa.df.filtre)] # supprimer la colonne fréquence
summary(colSums(mfa.df.final)) # on vérifie le nombre min, max, médian, moyen de mots par thèmes pour voir l'impact du filtrage ## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 1.000 5.000 6.000 5.722 7.000 7.000
## [1] 247 90
## [1] 132 90
On va ensuite comparer deux méthodes pour l’obtention des formes fortes : un AFM avec autant de groupes de variables que de nb.lda et pour chaque groupe autant de variables que de k, et une AFC avec une transformation des fréquences en modalités, et autant de variables de termes uniques dans le vocabulaire.
L’AFM est une analyse dimensionnelle qui permet d’imposer une structure sur les variables, ce qui est nécessaire ici car chaque topic n’a de sens qu’au sein d’une exécution de la LDA, et les mots peuvent être parfois partagés au sein d’une lda ou entre topics de plusieurs LDA.
res.mfa <- MFA(base = mfa.df.final,
group = rep(k,nb_lda),
type = rep("f",nb_lda),
name.group = paste0("lda",seq(1:nb_lda)),
graph = FALSE
)
# on affiche le scree plot pour choisir le nombre de composantes à conserver
barplot(res.mfa$eig[1:40,2])# on retient 5 composantes
res.mfa <- MFA(base = mfa.df.final,
group = rep(k,nb_lda),
type = rep("f",nb_lda),
name.group = paste0("lda",seq(1:nb_lda)),
ncp = 5
# graph = F
)On réalise ensuite une classification hierarchique de nos individus (mots).
On regarde le nombre optimal de clusters, les mots qui les composent et on essaye d’optimiser ce nombre de clusters.
clust7<- HCPC(res = res.mfa, nb.clust = 7, graph = FALSE)
clust8<- HCPC(res = res.mfa, nb.clust = 8, graph = F)Quel nombre de cluster a le plus de sens ?
plot_clust <- function(res.hcpc){
clust <- data.frame(cbind(word = rownames(mfa.df.final),
clust = res.hcpc$data.clust$clust,
dim1 = res.mfa$ind$coord[,1],
dim2 = res.mfa$ind$coord[,2]))
str(clust)
clust$clust <- as.factor(clust$clust)
clust$word <- as.factor((clust$word))
clust$dim1 <- as.numeric(clust$dim1)
clust$dim2 <- as.numeric(clust$dim2)
plot <- plot_ly(
data = clust,
x = ~dim1,
y = ~dim2,
type = "scatter",
mode = "markers+text",
color = ~factor(clust),
text = ~word, # nom de ta colonne contenant les mots
textposition = "top center",
marker = list(size = 7),
hoverinfo = "text"
) %>%
layout(
title = "Projection des mots dans l'espace factoriel (Dim 1 & Dim 2)",
xaxis = list(
title = "Dimension 1", # supprime le titre
showticklabels = FALSE, # supprime les graduations
zeroline = FALSE
),
yaxis = list(
title = "Dimension 2",
showticklabels = FALSE,
zeroline = FALSE
),
legend = list(title = list(text = "Cluster"))
)
plot
}## 'data.frame': 132 obs. of 4 variables:
## $ word : chr "aop" "court" "circuit" "attente" ...
## $ clust: chr "3" "5" "5" "5" ...
## $ dim1 : chr "0.60036319115433" "0.83289278248596" "0.832892782485965" "0.922033804101742" ...
## $ dim2 : chr "-0.127983810117255" "1.00662789372137" "1.00662789372137" "0.320516068032617" ...
## 'data.frame': 132 obs. of 4 variables:
## $ word : chr "aop" "court" "circuit" "attente" ...
## $ clust: chr "5" "6" "6" "6" ...
## $ dim1 : chr "0.60036319115433" "0.83289278248596" "0.832892782485965" "0.922033804101742" ...
## $ dim2 : chr "-0.127983810117255" "1.00662789372137" "1.00662789372137" "0.320516068032617" ...
## 'data.frame': 132 obs. of 4 variables:
## $ word : chr "aop" "court" "circuit" "attente" ...
## $ clust: chr "5" "6" "6" "6" ...
## $ dim1 : chr "0.60036319115433" "0.83289278248596" "0.832892782485965" "0.922033804101742" ...
## $ dim2 : chr "-0.127983810117255" "1.00662789372137" "1.00662789372137" "0.320516068032617" ...
On choisit le nombre de clusters retenus :
et on extrait les coordonnées des individus et leur appartenance à un cluster :
# création du jdd contenant les mots, leurs coordonnées sur les dimensions 1 et 2 ainsi que leur topic
clust <- data.frame(cbind(word = rownames(mfa.df.final),
clust = res.hcpc$data.clust$clust,
dim1 = res.mfa$ind$coord[,1],
dim2 = res.mfa$ind$coord[,2]))
str(clust)## 'data.frame': 132 obs. of 4 variables:
## $ word : chr "aop" "court" "circuit" "attente" ...
## $ clust: chr "3" "5" "5" "5" ...
## $ dim1 : chr "0.60036319115433" "0.83289278248596" "0.832892782485965" "0.922033804101742" ...
## $ dim2 : chr "-0.127983810117255" "1.00662789372137" "1.00662789372137" "0.320516068032617" ...
clust$clust <- as.factor(clust$clust)
clust$word <- as.factor((clust$word))
clust$dim1 <- as.numeric(clust$dim1)
clust$dim2 <- as.numeric(clust$dim2)
head(clust)On récupère ensuite l’ensemble des mots de chaque clusters et on réalise l’extraction de la variable latente (nom du topic)
# récupération des mots de chaque clusters
mots.clust <- tapply(
clust$word, # Le vecteur à appliquer la fonction (les Mots)
clust$clust, # Le facteur de regroupement (les Clusters)
paste, # La fonction à appliquer
collapse = ", ") # L
# interprétation avec naileR (à faire plus tard)identification des variables latentes avec LLM :
Nous avons aussi essayé une AFM avec comme classe de variable ‘n’ => catégorielle.
afm.quali <- data.frame(lapply(mfa.df.final, FUN = as.factor ))
rownames(afm.quali) <- rownames(mfa.df.final)
# str(head(afm.quali))
res.fma.q <- MFA(base = afm.quali,
group = rep(k,nb_lda),
type = rep("n",nb_lda),
name.group = paste0("lda",seq(1:nb_lda))
)Il semblerait difficile d’identifier des formes fortes car en utilisant un type catégorielle, les mots ‘…’ , … tirent fortement les axes donc cette méthode ne permet pas de consolider notre LDA.
Si on fait une classification issue du résultat de l’AFC, il semblerait que les formes fortes observées soient les mêmes que dans la méthode 1.
Il semble intéressant d’utiliser des analyses factorielles pour consolider nos topic modellings et obtenir des formes fortes de nos topics. Après avoir lancé cet algorithme en faisant varier beaucoup les paramètres, on a pu observer une relative sensabilité à la modification de la stop_words liste des mots, ainsi évidemment qu’au paramètre k, ainsi que des topics très “forts” toujours retrouvés et composés des mêmes termes.
Le résultat présenté (6 clusters) nous semble cohérents au vue de tous les essais réalisés, rendant compte de thématiques qui portent du sens (bien que certaines soient composés de plusieurs sous-sujets), et que l’on a retrouvé systématiquement.